home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2002 November / CD 1 / APC0211D1.ISO / workshop / prog / files / ActivePerl-5.6.1.633-MSWin32.msi / _fa801cacb799e675114307382f23a9bc < prev    next >
Encoding:
Text File  |  2002-06-17  |  23.4 KB  |  846 lines
  1. @rem = '--*-Perl-*--
  2. @echo off
  3. if "%OS%" == "Windows_NT" goto WinNT
  4. perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
  5. goto endofperl
  6. :WinNT
  7. perl -x -S %0 %*
  8. if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
  9. if %errorlevel% == 9009 echo You do not have Perl in your PATH.
  10. if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
  11. goto endofperl
  12. @rem ';
  13. #!perl
  14. #line 15
  15.     eval 'exec C:\p4view\Apps\ActivePerl\MSI\data\ActivePerl\Perl\bin\perl.exe -S $0 ${1+"$@"}'
  16.     if 0;
  17.  
  18. use warnings;
  19. use strict;
  20.  
  21. # make sure creat()s are neither too much nor too little
  22. INIT { eval { umask(0077) } }   # doubtless someone has no mask
  23.  
  24. (my $pager = <<'/../') =~ s/\s*\z//;
  25. more /e
  26. /../
  27. my @pagers = ();
  28. push @pagers, $pager if -x $pager;
  29.  
  30. (my $bindir = <<'/../') =~ s/\s*\z//;
  31. C:\p4view\Apps\ActivePerl\MSI\data\ActivePerl\Perl\bin
  32. /../
  33.  
  34.  
  35. use Fcntl;    # for sysopen
  36. use Getopt::Std;
  37. use Config '%Config';
  38. use File::Spec::Functions qw(catfile splitdir);
  39.  
  40. #
  41. # Perldoc revision #1 -- look up a piece of documentation in .pod format that
  42. # is embedded in the perl installation tree.
  43. #
  44. # This is not to be confused with Tom Christiansen's perlman, which is a
  45. # man replacement, written in perl. This perldoc is strictly for reading
  46. # the perl manuals, though it too is written in perl.
  47. # 
  48. # Massive security and correctness patches applied to this
  49. # noisome program by Tom Christiansen Sat Mar 11 15:22:33 MST 2000 
  50.  
  51. if (@ARGV<1) {
  52.     my $me = $0;        # Editing $0 is unportable
  53.     $me =~ s,.*/,,;
  54.     die <<EOF;
  55. Usage: $me [-h] [-r] [-i] [-v] [-t] [-u] [-m] [-n program] [-l] [-F] [-X] PageName|ModuleName|ProgramName
  56.        $me -f PerlFunc
  57.        $me -q FAQKeywords
  58.  
  59. The -h option prints more help.  Also try "perldoc perldoc" to get
  60. acquainted with the system.
  61. EOF
  62. }
  63.  
  64. my @global_found = ();
  65. my $global_target = "";
  66.  
  67. my $Is_VMS = $^O eq 'VMS';
  68. my $Is_MSWin32 = $^O eq 'MSWin32';
  69. my $Is_Dos = $^O eq 'dos';
  70. my $Is_OS2 = $^O eq 'os2';
  71.  
  72. sub usage{
  73.     warn "@_\n" if @_;
  74.     # Erase evidence of previous errors (if any), so exit status is simple.
  75.     $! = 0;
  76.     die <<EOF;
  77. perldoc [options] PageName|ModuleName|ProgramName...
  78. perldoc [options] -f BuiltinFunction
  79. perldoc [options] -q FAQRegex
  80.  
  81. Options:
  82.     -h   Display this help message
  83.     -r   Recursive search (slow)
  84.     -i   Ignore case
  85.     -t   Display pod using pod2text instead of pod2man and nroff
  86.              (-t is the default on win32)
  87.     -u     Display unformatted pod text
  88.     -m   Display module's file in its entirety
  89.     -n   Specify replacement for nroff
  90.     -l   Display the module's file name
  91.     -F   Arguments are file names, not modules
  92.     -v     Verbosely describe what's going on
  93.     -X     use index if present (looks for pod.idx at $Config{archlib})
  94.     -q   Search the text of questions (not answers) in perlfaq[1-9]
  95.     -U     Run in insecure mode (superuser only)
  96.  
  97. PageName|ModuleName...
  98.          is the name of a piece of documentation that you want to look at. You
  99.          may either give a descriptive name of the page (as in the case of
  100.          `perlfunc') the name of a module, either like `Term::Info',
  101.          `Term/Info', the partial name of a module, like `info', or
  102.          `makemaker', or the name of a program, like `perldoc'.
  103.  
  104. BuiltinFunction
  105.          is the name of a perl function.  Will extract documentation from
  106.          `perlfunc'.
  107.  
  108. FAQRegex
  109.          is a regex. Will search perlfaq[1-9] for and extract any
  110.          questions that match.
  111.  
  112. Any switches in the PERLDOC environment variable will be used before the
  113. command line arguments.  The optional pod index file contains a list of
  114. filenames, one per line.
  115.  
  116. EOF
  117. }
  118.  
  119. if (defined $ENV{"PERLDOC"}) {
  120.     require Text::ParseWords;
  121.     unshift(@ARGV, Text::ParseWords::shellwords($ENV{"PERLDOC"}));
  122. }
  123.  
  124. use vars qw( $opt_m $opt_h $opt_t $opt_l $opt_u $opt_v $opt_r $opt_i $opt_F $opt_f $opt_X $opt_q $opt_n $opt_U );
  125.  
  126. getopts("mhtluvriFf:Xq:n:U") || usage;
  127.  
  128. usage if $opt_h;
  129.  
  130. # refuse to run if we should be tainting and aren't
  131. # (but regular users deserve protection too, though!)
  132. if (!($Is_VMS || $Is_MSWin32 || $Is_Dos || $Is_OS2) && ($> == 0 || $< == 0)
  133.      && !am_taint_checking()) 
  134. {{
  135.     if ($opt_U) {
  136.         my $id = eval { getpwnam("nobody") };
  137.            $id = eval { getpwnam("nouser") } unless defined $id;
  138.            $id = -2 unless defined $id;
  139.         eval {
  140.             $> = $id;  # must do this one first!
  141.             $< = $id;
  142.         };
  143.         last if !$@ && $< && $>;
  144.     }
  145.     die "Superuser must not run $0 without security audit and taint checks.\n";
  146. }}
  147.  
  148. $opt_n = "nroff" if !$opt_n;
  149.  
  150. my $podidx;
  151. if ($opt_X) {
  152.     $podidx = "$Config{'archlib'}/pod.idx";
  153.     $podidx = "" unless -f $podidx && -r _ && -M _ <= 7;
  154. }
  155.  
  156. if ((my $opts = do{ no warnings; $opt_t + $opt_u + $opt_m + $opt_l }) > 1) {
  157.     usage("only one of -t, -u, -m or -l")
  158. }
  159. elsif ($Is_MSWin32
  160.        || $Is_Dos
  161.        || !($ENV{TERM} && $ENV{TERM} !~ /dumb|emacs|none|unknown/i))
  162. {
  163.     $opt_t = 1 unless $opts;
  164. }
  165.  
  166. if ($opt_t) { require Pod::Text; import Pod::Text; }
  167.  
  168. my @pages;
  169. if ($opt_f) {
  170.     @pages = ("perlfunc");
  171. }
  172. elsif ($opt_q) {
  173.     @pages = ("perlfaq1" .. "perlfaq9");
  174. }
  175. else {
  176.     @pages = @ARGV;
  177. }
  178.  
  179. # Does this look like a module or extension directory?
  180. if (-f "Makefile.PL") {
  181.  
  182.     # Add ., lib to @INC (if they exist)
  183.     eval q{ use lib qw(. lib); 1; } or die;
  184.  
  185.     # don't add if superuser
  186.     if ($< && $> && -f "blib") {   # don't be looking too hard now!
  187.     eval q{ use blib; 1 };
  188.     warn $@ if $@ && $opt_v;
  189.     }
  190. }
  191.  
  192. sub containspod {
  193.     my($file, $readit) = @_;
  194.     return 1 if !$readit && $file =~ /\.pod\z/i;
  195.     local($_);
  196.     open(TEST,"<", $file)     or die "Can't open $file: $!";
  197.     while (<TEST>) {
  198.     if (/^=head/) {
  199.         close(TEST)     or die "Can't close $file: $!";
  200.         return 1;
  201.     }
  202.     }
  203.     close(TEST)         or die "Can't close $file: $!";
  204.     return 0;
  205. }
  206.  
  207. sub minus_f_nocase {
  208.      my($dir,$file) = @_;
  209.      my $path = catfile($dir,$file);
  210.      return $path if -f $path and -r _;
  211.      if (!$opt_i or $Is_VMS or $Is_MSWin32 or $Is_Dos or $^O eq 'os2') {
  212.         # on a case-forgiving file system or if case is important
  213.     # that is it all we can do
  214.     warn "Ignored $path: unreadable\n" if -f _;
  215.     return '';
  216.      }
  217.      local *DIR;
  218.      # this is completely wicked.  don't mess with $", and if 
  219.      # you do, don't assume / is the dirsep!
  220.      local($")="/";
  221.      my @p = ($dir);
  222.      my($p,$cip);
  223.      foreach $p (splitdir $file){
  224.     my $try = catfile @p, $p;
  225.     stat $try;
  226.      if (-d _) {
  227.          push @p, $p;
  228.         if ( $p eq $global_target) {
  229.         my $tmp_path = catfile @p;
  230.         my $path_f = 0;
  231.         for (@global_found) {
  232.             $path_f = 1 if $_ eq $tmp_path;
  233.         }
  234.         push (@global_found, $tmp_path) unless $path_f;
  235.         print STDERR "Found as @p but directory\n" if $opt_v;
  236.         }
  237.      }
  238.     elsif (-f _ && -r _) {
  239.          return $try;
  240.      }
  241.     elsif (-f _) {
  242.         warn "Ignored $try: unreadable\n";
  243.      }
  244.     elsif (-d "@p") {
  245.          my $found=0;
  246.          my $lcp = lc $p;
  247.          opendir DIR, "@p"         or die "opendir @p: $!";
  248.          while ($cip=readdir(DIR)) {
  249.          if (lc $cip eq $lcp){
  250.              $found++;
  251.              last;
  252.          }
  253.          }
  254.          closedir DIR        or die "closedir @p: $!";
  255.          return "" unless $found;
  256.          push @p, $cip;
  257.          return "@p" if -f "@p" and -r _;
  258.         warn "Ignored @p: unreadable\n" if -f _;
  259.      }
  260.      }
  261.      return "";
  262. }
  263.  
  264.  
  265. sub check_file {
  266.     my($dir,$file) = @_;
  267.     return "" if length $dir and not -d $dir;
  268.     if ($opt_m) {
  269.     return minus_f_nocase($dir,$file);
  270.     }
  271.     else {
  272.     my $path = minus_f_nocase($dir,$file);
  273.         return $path if length $path and containspod($path);
  274.     }
  275.     return "";
  276. }
  277.  
  278.  
  279. sub searchfor {
  280.     my($recurse,$s,@dirs) = @_;
  281.     $s =~ s!::!/!g;
  282.     $s = VMS::Filespec::unixify($s) if $Is_VMS;
  283.     return $s if -f $s && containspod($s);
  284.     printf STDERR "Looking for $s in @dirs\n" if $opt_v;
  285.     my $ret;
  286.     my $i;
  287.     my $dir;
  288.     $global_target = (splitdir $s)[-1];   # XXX: why not use File::Basename?
  289.     for ($i=0; $i<@dirs; $i++) {
  290.     $dir = $dirs[$i];
  291.     ($dir = VMS::Filespec::unixpath($dir)) =~ s!/\z!! if $Is_VMS;
  292.     if (       ( $ret = check_file $dir,"$s.pod")
  293.         or ( $ret = check_file $dir,"$s.pm")
  294.         or ( $ret = check_file $dir,$s)
  295.         or ( $Is_VMS and
  296.              $ret = check_file $dir,"$s.com")
  297.         or ( $^O eq 'os2' and
  298.              $ret = check_file $dir,"$s.cmd")
  299.         or ( ($Is_MSWin32 or $Is_Dos or $^O eq 'os2') and
  300.              $ret = check_file $dir,"$s.bat")
  301.         or ( $ret = check_file "$dir/pod","$s.pod")
  302.         or ( $ret = check_file "$dir/pod",$s)
  303.         or ( $ret = check_file "$dir/pods","$s.pod")
  304.         or ( $ret = check_file "$dir/pods",$s)
  305.     ) {
  306.         return $ret;
  307.     }
  308.  
  309.     if ($recurse) {
  310.         opendir(D,$dir)    or die "Can't opendir $dir: $!";
  311.         my @newdirs = map catfile($dir, $_), grep {
  312.         not /^\.\.?\z/s and
  313.         not /^auto\z/s  and   # save time! don't search auto dirs
  314.         -d  catfile($dir, $_)
  315.         } readdir D;
  316.         closedir(D)        or die "Can't closedir $dir: $!";
  317.         next unless @newdirs;
  318.         # what a wicked map!
  319.         @newdirs = map((s/\.dir\z//,$_)[1],@newdirs) if $Is_VMS;
  320.         print STDERR "Also looking in @newdirs\n" if $opt_v;
  321.         push(@dirs,@newdirs);
  322.     }
  323.     }
  324.     return ();
  325. }
  326.  
  327. sub filter_nroff {
  328.   my @data = split /\n{2,}/, shift;
  329.   shift @data while @data and $data[0] !~ /\S/; # Go to header
  330.   shift @data if @data and $data[0] =~ /Contributed\s+Perl/; # Skip header
  331.   pop @data if @data and $data[-1] =~ /^\w/; # Skip footer, like
  332.                 # 28/Jan/99 perl 5.005, patch 53 1
  333.   join "\n\n", @data;
  334. }
  335.  
  336. sub printout {
  337.     my ($file, $tmp, $filter) = @_;
  338.     my $err;
  339.  
  340.     if ($opt_t) {
  341.     # why was this append?
  342.     sysopen(OUT, $tmp, O_WRONLY | O_EXCL | O_CREAT, 0600)
  343.         or die ("Can't open $tmp: $!");
  344.     Pod::Text->new()->parse_from_file($file,\*OUT);
  345.     close OUT   or die "can't close $tmp: $!";
  346.     }
  347.     elsif (not $opt_u) {
  348.     my $cmd = catfile($bindir, 'pod2man') . " --lax $file | $opt_n -man";
  349.     $cmd .= " | col -x" if $^O =~ /hpux/;
  350.     my $rslt = `$cmd`;
  351.     $rslt = filter_nroff($rslt) if $filter;
  352.     unless (($err = $?)) {
  353.         # why was this append?
  354.         sysopen(TMP, $tmp, O_WRONLY | O_EXCL | O_CREAT, 0600)
  355.         or die "Can't open $tmp: $!";
  356.         print TMP $rslt
  357.         or die "Can't print $tmp: $!";
  358.         close TMP
  359.         or die "Can't close $tmp: $!";
  360.     }
  361.     }
  362.     if ($opt_u or $err or -z $tmp) {  # XXX: race with -z
  363.     # why was this append?
  364.     sysopen(OUT, $tmp, O_WRONLY | O_EXCL | O_CREAT, 0600)
  365.         or die "Can't open $tmp: $!";
  366.     open(IN,"<", $file)   or die("Can't open $file: $!");
  367.     my $cut = 1;
  368.     local $_;
  369.     while (<IN>) {
  370.         $cut = $1 eq 'cut' if /^=(\w+)/;
  371.         next if $cut;
  372.         print OUT
  373.         or die "Can't print $tmp: $!";
  374.     }
  375.     close IN    or die "Can't close $file: $!";
  376.     close OUT   or die "Can't close $tmp: $!";
  377.     }
  378. }
  379.  
  380. sub page {
  381.     my ($tmp, $no_tty, @pagers) = @_;
  382.     if ($no_tty) {
  383.     open(TMP,"<", $tmp)     or die "Can't open $tmp: $!";
  384.     local $_;
  385.     while (<TMP>) {
  386.         print or die "Can't print to stdout: $!";
  387.     } 
  388.     close TMP        or die "Can't close while $tmp: $!";
  389.     }
  390.     else {
  391.     foreach my $pager (@pagers) {
  392.           if ($Is_VMS) {
  393.            last if system("$pager $tmp") == 0; # quoting prevents logical expansion
  394.           } else {
  395.         last if system("$pager \"$tmp\"") == 0;
  396.           }
  397.     }
  398.     }
  399. }
  400.  
  401. sub cleanup {
  402.     my @files = @_;
  403.     for (@files) {
  404.     if ($Is_VMS) { 
  405.         1 while unlink($_);    # XXX: expect failure
  406.     } else {
  407.         unlink($_);           # or die "Can't unlink $_: $!";
  408.     } 
  409.     }
  410. }
  411.  
  412. my @found;
  413. foreach (@pages) {
  414.     if ($podidx && open(PODIDX, $podidx)) {
  415.     my $searchfor = catfile split '::';
  416.     print STDERR "Searching for '$searchfor' in $podidx\n" if $opt_v;
  417.     local $_;
  418.     while (<PODIDX>) {
  419.         chomp;
  420.         push(@found, $_) if m,/$searchfor(?:\.(?:pod|pm))?\z,i;
  421.     }
  422.     close(PODIDX)        or die "Can't close $podidx: $!";
  423.     next;
  424.     }
  425.     print STDERR "Searching for $_\n" if $opt_v;
  426.     # We must look both in @INC for library modules and in $bindir
  427.     # for executables, like h2xs or perldoc itself.
  428.     my @searchdirs = ($bindir, @INC);
  429.     if ($opt_F) {
  430.     next unless -r;
  431.     push @found, $_ if $opt_m or containspod($_);
  432.     next;
  433.     }
  434.     unless ($opt_m) {
  435.     if ($Is_VMS) {
  436.         my($i,$trn);
  437.         for ($i = 0; $trn = $ENV{'DCL$PATH;'.$i}; $i++) {
  438.         push(@searchdirs,$trn);
  439.         }
  440.         push(@searchdirs,'perl_root:[lib.pod]')  # installed pods
  441.     }
  442.     else {
  443.         push(@searchdirs, grep(-d, split($Config{path_sep},
  444.                          $ENV{'PATH'})));
  445.     }
  446.     }
  447.     my @files = searchfor(0,$_,@searchdirs);
  448.     if (@files) {
  449.     print STDERR "Found as @files\n" if $opt_v;
  450.     }
  451.     else {
  452.     # no match, try recursive search
  453.     @searchdirs = grep(!/^\.\z/s,@INC);
  454.     @files= searchfor(1,$_,@searchdirs) if $opt_r;
  455.     if (@files) {
  456.         print STDERR "Loosely found as @files\n" if $opt_v;
  457.     }
  458.     else {
  459.         print STDERR "No documentation found for \"$_\".\n";
  460.         if (@global_found) {
  461.         print STDERR "However, try\n";
  462.         for my $dir (@global_found) {
  463.             opendir(DIR, $dir) or die "opendir $dir: $!";
  464.             while (my $file = readdir(DIR)) {
  465.             next if ($file =~ /^\./s);
  466.             $file =~ s/\.(pm|pod)\z//;  # XXX: badfs
  467.             print STDERR "\tperldoc $_\::$file\n";
  468.             }
  469.             closedir DIR    or die "closedir $dir: $!";
  470.         }
  471.         }
  472.     }
  473.     }
  474.     push(@found,@files);
  475. }
  476.  
  477. if (!@found) {
  478.     exit ($Is_VMS ? 98962 : 1);
  479. }
  480.  
  481. if ($opt_l) {
  482.     print join("\n", @found), "\n";
  483.     exit;
  484. }
  485.  
  486. my $lines = $ENV{LINES} || 24;
  487.  
  488. my $no_tty;
  489. if (! -t STDOUT) { $no_tty = 1 }
  490. END { close(STDOUT) || die "Can't close STDOUT: $!" }
  491.  
  492. # until here we could simply exit or die
  493. # now we create temporary files that we have to clean up
  494. # namely $tmp, $buffer
  495. # that's because you did it wrong, should be descriptor based --tchrist
  496.  
  497. my $tmp;
  498. my $buffer;
  499. if ($Is_MSWin32) {
  500.     $tmp = "$ENV{TEMP}\\perldoc1.$$";
  501.     $buffer = "$ENV{TEMP}\\perldoc1.b$$";
  502.     push @pagers, qw( more< less notepad );
  503.     unshift @pagers, $ENV{PAGER}  if $ENV{PAGER};
  504.     for (@found) { s,/,\\,g }
  505. }
  506. elsif ($Is_VMS) {
  507.     $tmp = 'Sys$Scratch:perldoc.tmp1_'.$$;
  508.     $buffer = 'Sys$Scratch:perldoc.tmp1_b'.$$;
  509.     push @pagers, qw( most more less type/page );
  510. }
  511. elsif ($Is_Dos) {
  512.     $tmp = "$ENV{TEMP}/perldoc1.$$";
  513.     $buffer = "$ENV{TEMP}/perldoc1.b$$";
  514.     $tmp =~ tr!\\/!//!s;
  515.     $buffer =~ tr!\\/!//!s;
  516.     push @pagers, qw( less.exe more.com< );
  517.     unshift @pagers, $ENV{PAGER}  if $ENV{PAGER};
  518. }
  519. else {
  520.     if ($^O eq 'os2') {
  521.       require POSIX;
  522.       $tmp = POSIX::tmpnam();
  523.       $buffer = POSIX::tmpnam();
  524.       unshift @pagers, 'less', 'cmd /c more <';
  525.     }
  526.     else {
  527.       # XXX: this is not secure, because it doesn't open it
  528.       ($tmp, $buffer) = eval { require POSIX } 
  529.         ? (POSIX::tmpnam(),    POSIX::tmpnam()     )
  530.         : ("/tmp/perldoc1.$$", "/tmp/perldoc1.b$$" );
  531.     }
  532.     push @pagers, qw( more less pg view cat );
  533.     unshift @pagers, $ENV{PAGER}  if $ENV{PAGER};
  534. }
  535. unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER};
  536.  
  537. # make sure cleanup called
  538. eval q{
  539.     sub END { cleanup($tmp, $buffer) } 
  540.     1;
  541. } || die;
  542.  
  543. # exit/die in a windows sighandler is dangerous, so let it do the
  544. # default thing, which is to exit
  545. eval q{ use sigtrap qw(die INT TERM HUP QUIT) } unless $^O eq 'MSWin32';
  546.  
  547. if ($opt_m) {
  548.     foreach my $pager (@pagers) {
  549.     if (system($pager, @found) == 0) {
  550.         exit;
  551.     }
  552.     }
  553.     if ($Is_VMS) { 
  554.     eval q{
  555.         use vmsish qw(status exit); 
  556.         exit $?;
  557.         1;
  558.     } or die;
  559.     }
  560.     exit(1);
  561. }
  562.  
  563. my @pod;
  564. if ($opt_f) {
  565.     my $perlfunc = shift @found;
  566.     open(PFUNC, "<", $perlfunc)
  567.     or die("Can't open $perlfunc: $!");
  568.  
  569.     # Functions like -r, -e, etc. are listed under `-X'.
  570.     my $search_string = ($opt_f =~ /^-[rwxoRWXOeszfdlpSbctugkTBMAC]$/)
  571.             ? 'I<-X' : $opt_f ;
  572.  
  573.     # Skip introduction
  574.     local $_;
  575.     while (<PFUNC>) {
  576.     last if /^=head2 Alphabetical Listing of Perl Functions/;
  577.     }
  578.  
  579.     # Look for our function
  580.     my $found = 0;
  581.     my $inlist = 0;
  582.     while (<PFUNC>) {
  583.     if (/^=item\s+\Q$search_string\E\b/o)  {
  584.         $found = 1;
  585.     }
  586.     elsif (/^=item/) {
  587.         last if $found > 1 and not $inlist;
  588.     }
  589.     next unless $found;
  590.     if (/^=over/) {
  591.         ++$inlist;
  592.     }
  593.     elsif (/^=back/) {
  594.         --$inlist;
  595.     }
  596.     push @pod, $_;
  597.     ++$found if /^\w/;    # found descriptive text
  598.     }
  599.     if (!@pod) {
  600.     die "No documentation for perl function `$opt_f' found\n";
  601.     }
  602.     close PFUNC        or die "Can't open $perlfunc: $!";
  603. }
  604.  
  605. if ($opt_q) {
  606.     local @ARGV = @found;    # I'm lazy, sue me.
  607.     my $found = 0;
  608.     my %found_in;
  609.     my $rx = eval { qr/$opt_q/ } or die <<EOD;
  610. Invalid regular expression '$opt_q' given as -q pattern:
  611.   $@
  612. Did you mean \\Q$opt_q ?
  613.  
  614. EOD
  615.  
  616.     for (@found) { die "invalid file spec: $!" if /[<>|]/ } 
  617.     local $_;
  618.     while (<>) {
  619.     if (/^=head2\s+.*(?:$opt_q)/oi) {
  620.         $found = 1;
  621.         push @pod, "=head1 Found in $ARGV\n\n" unless $found_in{$ARGV}++;
  622.     }
  623.     elsif (/^=head2/) {
  624.         $found = 0;
  625.     }
  626.     next unless $found;
  627.     push @pod, $_;
  628.     }
  629.     if (!@pod) {
  630.     die("No documentation for perl FAQ keyword `$opt_q' found\n");
  631.     }
  632. }
  633.  
  634. my $filter;
  635.  
  636. if (@pod) {
  637.     sysopen(TMP, $buffer, O_WRONLY | O_EXCL | O_CREAT)
  638.     or die("Can't open $buffer: $!");
  639.     print TMP "=over 8\n\n";
  640.     print TMP @pod    or die "Can't print $buffer: $!";
  641.     print TMP "=back\n";
  642.     close TMP        or die "Can't close $buffer: $!";
  643.     @found = $buffer;
  644.     $filter = 1;
  645. }
  646.  
  647. foreach (@found) {
  648.     printout($_, $tmp, $filter);
  649. }
  650. page($tmp, $no_tty, @pagers);
  651.  
  652. exit;
  653.  
  654. sub is_tainted {
  655.     my $arg = shift;
  656.     my $nada = substr($arg, 0, 0);  # zero-length
  657.     local $@;  # preserve caller's version
  658.     eval { eval "# $nada" };
  659.     return length($@) != 0;
  660. }
  661.  
  662. sub am_taint_checking {
  663.     my($k,$v) = each %ENV;
  664.     return is_tainted($v);  
  665. }
  666.  
  667.  
  668. __END__
  669.  
  670. =head1 NAME
  671.  
  672. perldoc - Look up Perl documentation in pod format.
  673.  
  674. =head1 SYNOPSIS
  675.  
  676. B<perldoc> [B<-h>] [B<-v>] [B<-t>] [B<-u>] [B<-m>] [B<-l>] [B<-F>]  [B<-X>] PageName|ModuleName|ProgramName
  677.  
  678. B<perldoc> B<-f> BuiltinFunction
  679.  
  680. B<perldoc> B<-q> FAQ Keyword
  681.  
  682. =head1 DESCRIPTION
  683.  
  684. I<perldoc> looks up a piece of documentation in .pod format that is embedded
  685. in the perl installation tree or in a perl script, and displays it via
  686. C<pod2man | nroff -man | $PAGER>. (In addition, if running under HP-UX,
  687. C<col -x> will be used.) This is primarily used for the documentation for
  688. the perl library modules.
  689.  
  690. Your system may also have man pages installed for those modules, in
  691. which case you can probably just use the man(1) command.
  692.  
  693. =head1 OPTIONS
  694.  
  695. =over 5
  696.  
  697. =item B<-h> help
  698.  
  699. Prints out a brief help message.
  700.  
  701. =item B<-v> verbose
  702.  
  703. Describes search for the item in detail.
  704.  
  705. =item B<-t> text output
  706.  
  707. Display docs using plain text converter, instead of nroff. This may be faster,
  708. but it won't look as nice.
  709.  
  710. =item B<-u> unformatted
  711.  
  712. Find docs only; skip reformatting by pod2*
  713.  
  714. =item B<-m> module
  715.  
  716. Display the entire module: both code and unformatted pod documentation.
  717. This may be useful if the docs don't explain a function in the detail
  718. you need, and you'd like to inspect the code directly; perldoc will find
  719. the file for you and simply hand it off for display.
  720.  
  721. =item B<-l> file name only
  722.  
  723. Display the file name of the module found.
  724.  
  725. =item B<-F> file names
  726.  
  727. Consider arguments as file names, no search in directories will be performed.
  728.  
  729. =item B<-f> perlfunc
  730.  
  731. The B<-f> option followed by the name of a perl built in function will
  732. extract the documentation of this function from L<perlfunc>.
  733.  
  734. =item B<-q> perlfaq
  735.  
  736. The B<-q> option takes a regular expression as an argument.  It will search
  737. the question headings in perlfaq[1-9] and print the entries matching
  738. the regular expression.
  739.  
  740. =item B<-X> use an index if present
  741.  
  742. The B<-X> option looks for a entry whose basename matches the name given on the
  743. command line in the file C<$Config{archlib}/pod.idx>.  The pod.idx file should
  744. contain fully qualified filenames, one per line.
  745.  
  746. =item B<-U> run insecurely
  747.  
  748. Because B<perldoc> does not run properly tainted, and is known to
  749. have security issues, it will not normally execute as the superuser.
  750. If you use the B<-U> flag, it will do so, but only after setting
  751. the effective and real IDs to nobody's or nouser's account, or -2
  752. if unavailable.  If it cannot relinguish its privileges, it will not
  753. run.  
  754.  
  755. =item B<PageName|ModuleName|ProgramName>
  756.  
  757. The item you want to look up.  Nested modules (such as C<File::Basename>)
  758. are specified either as C<File::Basename> or C<File/Basename>.  You may also
  759. give a descriptive name of a page, such as C<perlfunc>. You may also give a
  760. partial or wrong-case name, such as "basename" for "File::Basename", but
  761. this will be slower, if there is more then one page with the same partial
  762. name, you will only get the first one.
  763.  
  764. =back
  765.  
  766. =head1 ENVIRONMENT
  767.  
  768. Any switches in the C<PERLDOC> environment variable will be used before the
  769. command line arguments.  C<perldoc> also searches directories
  770. specified by the C<PERL5LIB> (or C<PERLLIB> if C<PERL5LIB> is not
  771. defined) and C<PATH> environment variables.
  772. (The latter is so that embedded pods for executables, such as
  773. C<perldoc> itself, are available.)  C<perldoc> will use, in order of
  774. preference, the pager defined in C<PERLDOC_PAGER>, C<MANPAGER>, or
  775. C<PAGER> before trying to find a pager on its own.  (C<MANPAGER> is not
  776. used if C<perldoc> was told to display plain text or unformatted pod.)
  777.  
  778. One useful value for C<PERLDOC_PAGER> is C<less -+C -E>.
  779.  
  780. =head1 VERSION
  781.  
  782. This is perldoc v2.03.
  783.  
  784. =head1 AUTHOR
  785.  
  786. Kenneth Albanowski <kjahds@kjahds.com>
  787.  
  788. Minor updates by Andy Dougherty <doughera@lafcol.lafayette.edu>,
  789. and others.
  790.  
  791. =cut
  792.  
  793. #
  794. # Version 2.03: Sun Apr 23 16:56:34 BST 2000
  795. #    Hugo van der Sanden <hv@crypt0.demon.co.uk>
  796. #    don't die when 'use blib' fails
  797. # Version 2.02: Mon Mar 13 18:03:04 MST 2000
  798. #       Tom Christiansen <tchrist@perl.com>
  799. #    Added -U insecurity option
  800. # Version 2.01: Sat Mar 11 15:22:33 MST 2000 
  801. #       Tom Christiansen <tchrist@perl.com>, querulously.
  802. #       Security and correctness patches.
  803. #       What a twisted bit of distasteful spaghetti code.
  804. # Version 2.0: ????
  805. # Version 1.15: Tue Aug 24 01:50:20 EST 1999
  806. #       Charles Wilson <cwilson@ece.gatech.edu>
  807. #    changed /pod/ directory to /pods/ for cygwin
  808. #         to support cygwin/win32
  809. # Version 1.14: Wed Jul 15 01:50:20 EST 1998
  810. #       Robin Barker <rmb1@cise.npl.co.uk>
  811. #    -strict, -w cleanups
  812. # Version 1.13: Fri Feb 27 16:20:50 EST 1997
  813. #       Gurusamy Sarathy <gsar@activestate.com>
  814. #    -doc tweaks for -F and -X options
  815. # Version 1.12: Sat Apr 12 22:41:09 EST 1997
  816. #       Gurusamy Sarathy <gsar@activestate.com>
  817. #    -various fixes for win32
  818. # Version 1.11: Tue Dec 26 09:54:33 EST 1995
  819. #       Kenneth Albanowski <kjahds@kjahds.com>
  820. #   -added Charles Bailey's further VMS patches, and -u switch
  821. #   -added -t switch, with pod2text support
  822. #
  823. # Version 1.10: Thu Nov  9 07:23:47 EST 1995
  824. #        Kenneth Albanowski <kjahds@kjahds.com>
  825. #    -added VMS support
  826. #    -added better error recognition (on no found pages, just exit. On
  827. #     missing nroff/pod2man, just display raw pod.)
  828. #    -added recursive/case-insensitive matching (thanks, Andreas). This
  829. #     slows things down a bit, unfortunately. Give a precise name, and
  830. #     it'll run faster.
  831. #
  832. # Version 1.01:    Tue May 30 14:47:34 EDT 1995
  833. #        Andy Dougherty  <doughera@lafcol.lafayette.edu>
  834. #   -added pod documentation.
  835. #   -added PATH searching.
  836. #   -added searching pod/ subdirectory (mainly to pick up perlfunc.pod
  837. #    and friends.
  838. #
  839. #
  840. # TODO:
  841. #
  842. #    Cache directories read during sloppy match
  843.  
  844. __END__
  845. :endofperl
  846.